<!DOCTYPE html>
<html lang="zh-cn">
  <head>
    <meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<meta name="generator" content="Hugo 0.82.0" />


<title>使用 VBA 拆分多 sheet 的 Excel 文件 - 宇飞的世界</title>
<meta property="og:title" content="使用 VBA 拆分多 sheet 的 Excel 文件 - 宇飞的世界">


  <link href='/favicon.ico' rel='icon' type='image/x-icon'/>



  








<link href='//cdnjs.cloudflare.com/ajax/libs/highlight.js/9.12.0/styles/github.min.css' rel='stylesheet' type='text/css' />



<link rel="stylesheet" href="/css/fonts.css" media="all">
<link rel="stylesheet" href="/css/main.css" media="all">



  </head>
  <body>
    <div class="wrapper">
      <header class="header">
        <nav class="nav">
  <a href="/" class="nav-logo">
    <img src="/images/logo.png"
         width="50"
         height="50"
         alt="Logo">
  </a>

  <ul class="nav-links">
    
    <li><a href="/about/">About</a></li>
    
    <li><a href="/categories/">Categories</a></li>
    
    <li><a href="/tags/">Tags</a></li>
    
    <li><a href="http://www.zhongyufei.com/Rbook/_book">R study</a></li>
    
  </ul>
</nav>

      </header>


<main class="content" role="main">

  <article class="article">
    
    <span class="article-duration">1 min read</span>
    

    <h1 class="article-title">使用 VBA 拆分多 sheet 的 Excel 文件</h1>

    
    <span class="article-date">2018-07-15</span>
    

    <div class="article-content">
      <h2 id="前言">前言</h2>
<p>当某 Excel 包含多个 Sheet　时，需要按照　Sheet　拆分成多个　Excel　文件，采用如下宏代码完成：</p>
<pre><code>' split sheet
Sub SaveAs()
    On Error Resume Next
    Dim FolderPath As String, FolderName As String, BN As String
    Dim ReturnValue As Integer

    BN = ActiveWorkbook.Name

    FolderPath = ThisWorkbook.Path
    FolderName = Mid(BN, 1, InStrRev(BN, &quot;.&quot;, Len(BN)) - 1)

    Dim MyFile As Object
    Set MyFile = CreateObject(&quot;Scripting.FileSystemObject&quot;)
    If MyFile.folderexists(FolderPath &amp; &quot;\&quot; &amp; FolderName &amp; &quot;-Saved&quot;) Then
        ReturnValue = MsgBox(&quot;文件夹已存在，是否更新内容？&quot;, vbOKCancel, &quot;Caution!&quot;)
        If ReturnValue = 2 Then Exit Sub
    Else
        MyFile.CreateFolder (FolderPath &amp; &quot;\&quot; &amp; FolderName &amp; &quot;-Saved&quot;)
        Set MyFile = Nothing
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim i As Integer

    For i = 1 To Sheets.Count
        Set Wk = Workbooks.Add
        Workbooks(BN).Sheets(i).Copy before:=Wk.Worksheets(&quot;Sheet1&quot;)
        Wk.SaveAs FolderPath &amp; &quot;\&quot; &amp; FolderName &amp; &quot;-Saved\&quot; &amp; ThisWorkbook.Sheets(i).Name, FileFormat:=xlExcel8
        Wk.Close
    Next i

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

</code></pre><p>使用方法：</p>
<p>将包含多<code>Sheet</code>的 Excel 中插入宏代码，点击运行即可。当情况变得复杂，如有条件筛选等其他情况，采用<code>R</code>或者<code>Python</code>等语言拆分较为简单。</p>

    </div>
  </article>

  


</main>

      <footer class="footer">
        <ul class="footer-links">
          <li>
            <a href="/index.xml" type="application/rss+xml" target="_blank">RSS feed</a>
          </li>
          <li>
            <a href="https://beian.miit.gov.cn/" target="_blank">粤ICP备20035539号</a>
          </li>
        </ul>
      </footer>

    </div>
    



<script src="//cdnjs.cloudflare.com/ajax/libs/highlight.js/9.12.0/highlight.min.js"></script>



<script src="//cdnjs.cloudflare.com/ajax/libs/highlight.js/9.12.0/languages/r.min.js"></script>
<script src="//cdnjs.cloudflare.com/ajax/libs/highlight.js/9.12.0/languages/yaml.min.js"></script>
<script>hljs.configure({languages: []}); hljs.initHighlightingOnLoad();</script>



    
<script src="/js/math-code.js"></script>
<script async src="//cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-MML-AM_CHTML"></script>


    
  </body>
</html>

